home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
SHELLS
/
SZ2
/
GCONVERT.IMP
< prev
next >
Wrap
Text File
|
1992-08-31
|
41KB
|
1,184 lines
{*******************************************************************
GCONVERT.IMP
*******************************************************************}
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
BOOLEAN
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
0/1 ==> "True "/"False"
===================================================================}
function BooleanTrueFalse ( B : boolean ) : string ;
begin
if B then
BooleanTrueFalse := 'True '
else
BooleanTrueFalse := 'False' ;
end ;
{===================================================================
0/1 ==> "Yes"/"No "
===================================================================}
function BooleanYesNo ( B : boolean ) : string ;
begin
if B then
BooleanYesNo := 'Yes'
else
BooleanYesNo := 'No ' ;
end ;
{===================================================================
0/1 ==> "On "/"Off"
===================================================================}
function BooleanOnOff ( B : boolean ) : string ;
begin
if B then
BooleanOnOff := 'On '
else
BooleanOnOff := 'Off' ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
NUMBER <-> STRING
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
REAL "999.9" --> 999.9
===================================================================}
function StrToReal ( S : string ) : real ;
var
R : real ;
code : integer ;
begin
StrToReal := 0 ;
Val ( S , R , code ) ;
if code = 0 then
StrToReal := R ;
end ;
{===================================================================
RANGE - need this cause "Val" isn't too bright
===================================================================}
function Range ( S : string ; Low , High : real ) : boolean ;
var
R : real ;
begin
R := StrToReal ( S ) ;
Range := ( R >= Low ) and
( R <= High ) ;
end ;
{===================================================================
BYTE "999" -> 999
===================================================================}
function StrToByte ( S : string ) : byte ;
var
b : byte ;
code : integer ;
begin
StrToByte := 0 ;
if not Range ( S , 0 , 255 ) then EXIT ;
Val ( S , b , code ) ;
StrToByte := b ;
end ;
{===================================================================
INTEGER "999" --> 999
===================================================================}
function StrToShort ( S : string ) : shortint ;
var
i : shortint ;
code : integer ;
begin
StrToShort := 0 ;
Val ( S , i , code ) ;
if not Range ( S , -128 , 127 ) then EXIT ;
StrToShort := i ;
end ;
{===================================================================
INTEGER "999" --> 999
===================================================================}
function StrToInt ( S : string ) : integer ;
var
i : integer ;
code : integer ;
begin
StrToInt := 0 ;
Val ( S , i , code ) ;
if not Range ( S , -32768 , 32767 ) then EXIT ;
StrToInt := i ;
end ;
{===================================================================
WORD "999" --> 999
===================================================================}
function StrToWord ( S : string ) : word ;
var
W : word ;
code : integer ;
begin
StrToWord := 0 ;
Val ( S , W , code ) ;
if not Range ( S , 0 , 65535 ) then EXIT ;
StrToWord := W ;
end ;
{===================================================================
LONG "999" --> 999
===================================================================}
function StrToLong ( S : string ) : longint ;
var
L : longint ;
code : integer ;
begin
StrToLong := 0 ;
Val ( S , L , code ) ;
if not Range ( S , -2147483647 , 2147483647 ) then EXIT ;
StrToLong := L ;
end ;
{===================================================================
Byte,Shortint,Integer,Longint,Real --> String
===================================================================}
function NumToStr ( R : real ) : string ;
var
S1 ,
S2 : string ;
L : longint ;
begin
L := Trunc ( R ) ; { 1.23 --> 1 }
R := Frac ( R ) ; { 1.23 --> .23 }
Str ( L : -1 , S1 ) ;
Str ( R : -1 : 5 , S2 ) ;
SYSTEM.delete ( S2 , 1 , 1 ) ;
S1 := S1 + S2 ;
while S1 [ length ( S1 ) ] = '0' do
SYSTEM.delete ( S1 , length ( S1 ) , 1 ) ;
while S1 [ length ( S1 ) ] = '.' do
SYSTEM.delete ( S1 , length ( S1 ) , 1 ) ;
if S1 = '' then
S1 := '0' ;
NumToStr := S1 ;
end ;
{===================================================================
DOS - When 100's or Day of week can be ignored.
===================================================================}
procedure GetDateTime ( VAR DT : DateTime ) ;
var
Sec100 ,
DoW : word ;
begin
GetDate ( DT.Year , DT.Month , DT.Day , DoW ) ;
GetTime ( DT.Hour , DT.Min , DT.Sec , Sec100 ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
VALIDITY CHECKS
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
LEAP YEAR - forces century if year less than 100
===================================================================}
function IsLeapYear ( Y : longint ) : boolean ;
var
DT : DateTime ;
begin
GetDateTime ( DT ) ;
if Y < 100 then
inc ( Y , ( DT.Year div 100 ) * 100 ) ;
IsLeapYear := Y mod 4 = 0 ;
end ;
{===================================================================
YEAR - greater than 0
===================================================================}
function IsYearValid ( Y : word ) : boolean ;
begin
IsYearValid := Y > 0 ;
end ;
{===================================================================
MONTH - 1 and 12
===================================================================}
function IsMonthValid ( M : word ) : boolean ;
begin
IsMonthValid := ( M >= 1 ) and ( M <= 12 ) ;
end ;
{===================================================================
DAY - as per month
===================================================================}
function MaxDayForMonth ( M , Y : word ) : word ;
begin
case M of
2 :
if IsLeapYear ( Y ) then
MaxDayForMonth := 29
else
MaxDayForMonth := 28 ;
4 ,
6,
9,
11 : MaxDayForMonth := 30 ;
else
MaxDayForMonth := 31 ;
end ;
end ;
{===================================================================
DAY - Valid for month
===================================================================}
function IsDayValid ( M , D , Y : word ) : boolean ;
begin
IsDayValid := ( D >= 1 ) and
( D <= MaxDayForMonth ( M , Y ) ) ;
end ;
{===================================================================
DATE - check all components
===================================================================}
function IsDateValid ( DT : DateTime ) : boolean ;
begin
IsDateValid := IsMonthValid ( DT.Month ) and
IsDayValid ( DT.Month , DT.Day , DT.Year ) and
IsYearValid ( DT.Year ) ;
end ;
{===================================================================
DATE - check all components
===================================================================}
function IsDateStrValid ( S : string ) : boolean ;
var
DT : DateTime ;
begin
DT.Month := 0 ;
DT.Day := 0 ;
DT.Year := 0 ;
StrToDate ( S , DT ) ;
IsDateStrValid := IsDateValid ( DT ) ;
end ;
{===================================================================
FORCE VALID - Set bad part to system date (today).
===================================================================}
procedure DateForceValid ( VAR DT : DateTime ) ;
var
Temp : DateTime ;
DoW : word ;
begin
DOS.GetDate ( Temp.Year , Temp.Month , Temp.Day , DoW ) ;
if not IsYearValid ( DT.Year ) then
DT.Year := Temp.Year ;
if not IsMonthValid ( DT.Month ) then
DT.Month := Temp.Month ;
if not IsDayValid ( DT.Month , DT.Day , DT.Year ) then
DT.Day := MaxDayForMonth ( DT.Month , DT.Year ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
DATE (Utility routines to convert date, string & date-format.)
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
Month to string
===================================================================}
function MonthToStr ( M : word ) : string ;
begin
case M of
1 : MonthToStr := 'January' ;
2 : MonthToStr := 'February' ;
3 : MonthToStr := 'March' ;
4 : MonthToStr := 'April' ;
5 : MonthToStr := 'May' ;
6 : MonthToStr := 'June' ;
7 : MonthToStr := 'July' ;
8 : MonthToStr := 'August' ;
9 : MonthToStr := 'September' ;
10 : MonthToStr := 'October' ;
11 : MonthToStr := 'November' ;
12 : MonthToStr := 'December' ;
else
MonthToStr := '???' ;
end ;
end ;
{===================================================================
Determine month by least chars.
===================================================================}
function StrToMonth ( S : string ) : byte ;
begin
S := CopyPos ( S , 1 , 3 ) ;
S := StrUpCase ( S ) ;
StrToMonth := 0 ; { "else" too complex }
case S [ 1 ] of
'A' : case S [ 2 ] of
'P' : StrToMonth := 4 ; { April }
'U' : StrToMonth := 8 ; { August }
end ;
'D' : StrToMonth := 12 ; { December }
'F' : StrToMonth := 2 ; { February }
'J' : case S [ 2 ] of
'A' : StrToMonth := 1 ; { January }
'U' : case S [ 3 ] of
'L' : StrToMonth := 7 ; { July }
'N' : StrToMonth := 6 ; { June }
end ;
end ;
'M' : if S [ 2 ] = 'A' then
case S [ 3 ] of
'R' : StrToMonth := 3 ; { March }
'Y' : StrToMonth := 5 ; { May }
end ;
'N' : StrToMonth := 11 ; { November }
'O' : StrToMonth := 10 ; { October }
'S' : StrToMonth := 9 ; { September }
end ;
end ;
{===================================================================
"date, month, year" --> word/word/word
Return word values for any of these formats:
1. mm/dd/yy ##/##/##
2. dd.mm.yy ##.##.##
3. dd-Mmm-yy ##-&??-##
NOTE: Date must be checked for validity!
===================================================================}
{-------------------------------------------------------------------
Return chars up to, but not including, "Ch".
Delete up to and including "Ch".
-------------------------------------------------------------------}
function GetTo ( VAR S : string ; Ch : char ) : string ;
var
b : byte ;
begin
b := pos ( Ch , S ) ;
if b = 0 then
begin
GetTo := CopyPos ( S , 1 , length ( S ) ) ;
S := '' ;
EXIT ;
end ;
GetTo := CopyPos ( S , 1 , b - 1 ) ;
delete ( S , 1 , b ) ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ROUTINE
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
procedure StrToDate ( S : string ; VAR DT : DateTime ) ;
var
Separator : char ;
Mo ,
Da ,
Yr : string ;
begin
if pos ( '/' , S ) > 0 then Separator := '/'
else
if pos ( '.' , S ) > 0 then Separator := '.'
else
if pos ( '-' , S ) > 0 then Separator := '-'
else
case DateType of
dtUS : Separator := '/' ;
dtUK : Separator := '.' ;
dtIntl : Separator := '-' ;
end ;
case Separator of
'/' :
begin
Mo := GetTo ( S , Separator ) ;
Da := GetTo ( S , Separator ) ;
Yr := GetTo ( S , Separator ) ;
if DateAutoAdjust then
DateType := dtUS ;
end ;
'.' :
begin
Da := GetTo ( S , Separator ) ;
Mo := GetTo ( S , Separator ) ;
Yr := GetTo ( S , Separator ) ;
if DateAutoAdjust then
DateType := dtUK ;
end ;
'-' :
begin
S := StrUpCase ( S ) ;
Da := GetTo ( S , Separator ) ;
Mo := GetTo ( S , Separator ) ;
Yr := GetTo ( S , Separator ) ;
Mo := NumToStr ( StrToMonth ( Mo ) ) ;
if DateAutoAdjust then
DateType := dtIntl ;
end ;
end ;
if IsYearValid ( StrToInt ( Yr ) ) then
DT.Year := StrToInt ( Yr ) ;
if IsMonthValid ( StrToInt ( Mo ) ) then
DT.Month := StrToInt ( Mo ) ;
if IsDayValid ( DT.Month , StrToInt ( Da ) , DT.Year ) then
DT.Day := StrToInt ( Da ) ;
end ;
{===================================================================
Return date as formatted string:
1. mm/dd/yyyy ##/##/####
2. dd.mm.yyyy ##.##.####
3. dd-Mmm-yyyy ##-&??-####
Also: Sets default DateType
===================================================================}
function DateToStr ( DT : DateTime ; Format : word ) : string ;
var
Temp ,
Mo ,
Da ,
Yr : string ;
begin
if DateAutoFill then
DateForceValid ( DT ) ;
if Format = dtIntl then
begin
Mo := MonthToStr ( DT.Month ) ;
if length ( Mo ) > 3 then
Mo := CopyPos ( Mo , 1 , 3 ) ;
end
else
begin
Mo := NumToStr ( DT.Month ) ;
Mo := PadLeft ( Mo , #32 , 2 ) ;
end ;
Da := NumToStr ( DT.Day ) ;
Da := PadLeft ( Da , #32 , 2 ) ;
Yr := NumToStr ( DT.Year ) ;
Yr := PadRight ( Yr , #32 , 4 ) ;
if not DateCentury then
delete ( Yr , 1 , 2 ) ;
case Format of
dtUS : Temp := Mo + '/' + Da + '/' + Yr ;
dtUK : Temp := Da + '.' + Mo + '.' + Yr ;
dtIntl : Temp := Da + '-' + Mo + '-' + Yr ;
else
begin
DateToStr := '' ;
EXIT ;
end ;
end ;
Temp := Replace ( Temp , #32 , '' ) ;
PadRight ( Temp , #32 , 11 ) ;
DateToStr := Temp ;
if DateAutoAdjust then
DateType := Format ;
end ;
{===================================================================
FORMAT
===================================================================}
function DateFormat ( S : string ; Format : word ) : string ;
var
DT : DateTime ;
begin
DT.Month := 0 ;
DT.Day := 0 ;
DT.Year := 0 ;
StrToDate ( S , DT ) ;
DateFormat := DateToStr ( DT , Format ) ;
end ;
{===================================================================
Return Mon, Tue, etc.
===================================================================}
function DayToStr ( DayOfWeek : word ) : string ;
begin
case DayOfWeek of
0 : DayToStr := 'Sunday' ;
1 : DayToStr := 'Monday' ;
2 : DayToStr := 'Tuesday' ;
3 : DayToStr := 'Wednesday' ;
4 : DayToStr := 'Thursday' ;
5 : DayToStr := 'Friday' ;
6 : DayToStr := 'Saturday' ;
else
DayToStr := '???' ;
end ;
end ;
{===================================================================
JULIAN DATES - are defined differently! Listed here by period start:
TERM DEFINITION EXAMPLE
---- ---------- -------
Gregorian Commonly used. 31 AUG 88
Astronomical Days since 1 JAN 4713 B.C. 2447405
NOTE: A day starts at 12:00 PM noon!
KnowledgeMan: Days since 15 OCT 1582 148244
NOTE: Valid until 31 DEC 9999
Zero if before or after.
Reflex : Days since 31 DEC 1899 32385
NOTE: Not accepted if before!
Military : Last digit of year, plus daycount. 8244
NOTE: Always a 4-digit number.
TEST DATE: 1 JAN 1930 = 2425978
SOURCE: Encyclopaedia Britannica, 1955 Edition
===================================================================}
{===================================================================
CCYY ==> CC Returns a two-digit number from the argument.
===================================================================}
function Century ( Y : word ) : word ;
begin
Century := Y div 100 ;
end ;
{===================================================================
91 ==> 1991 Add current century to year, if a 2-digit year given
===================================================================}
procedure MakeYearCentury ( VAR YY : word ) ;
var
DT : DateTime ;
begin
GetDateTime ( DT ) ;
if YY < 100 then
YY := ( Century ( DT.Year ) * 100 ) + YY
end ;
{===================================================================
MM, DD, YY ==> JJJJJJJJ ASTRONOMICAL JULIAN, The Real McCoy
===================================================================}
function ToJulian ( DT : DateTime ) : longint ;
var
L : longint ;
i : integer ;
j ,
temp : real ;
S : string ;
begin
if DT.Year < 100 then
MakeYearCentury ( DT.Year ) ;
Temp := int ( ( DT.Month - 14.0 ) / 12.0 ) ;
J := DT.Day - 32075.0 +
int ( 1461.0 * ( DT.Year + 4800.0 + temp ) / 4.0 ) +
int ( 367.0 * ( DT.Month - 2.0 - temp * 12.0 ) / 12.0 ) -
int ( 3.0 * int ( ( DT.Year + 4900.0 + temp ) / 100.0 ) / 4.0 ) ;
str ( J : 14 : 0 , S ) ;
val ( S , L , i ) ;
ToJulian := L ;
end ;
{===================================================================
JJJJJJJJ ==> MM, DD, YYYY
===================================================================}
procedure FromJulian ( JulianDay : real ; VAR DT : DateTime ) ;
var
tempA ,
tempB : real ;
begin
tempA := JulianDay + 68569.0 ;
tempB := int ( 4.0 * tempA / 146097.0 ) ;
tempA := tempA - int ( ( 146097.0 * tempB + 3.0 ) / 4.0 ) ;
DT.Year := trunc ( 4000.0 * ( tempA + 1.0 ) / 1461001.0 ) ;
tempA := tempA - int ( 1461.0 * DT.Year / 4.0 ) + 31.0 ;
DT.Month := trunc ( 80.0 * tempA / 2447.0 ) ;
DT.Day := trunc ( tempA - int ( 2447.0 * DT.Month / 80.0 ) ) ;
tempA := int ( DT.Month / 11.0 ) ;
DT.Month := trunc ( DT.Month + 2.0 - 12.0 * tempA ) ;
DT.Year := trunc ( 100.0 * ( tempB - 49.0 ) + DT.Year + tempA ) ;
end ;
{===================================================================
DAY COUNT
===================================================================}
function DaysBetween ( DT1 , DT2 : DateTime ) : longint ;
begin
DaysBetween := abs ( ToJulian ( DT1 ) - ToJulian ( DT2 ) ) ;
end ;
{===================================================================
ZELLER - Use Zeller's Congruence to compute day of the week
Returns a number from 0..6, Sun..Sat (same as DOS GetDate)
===================================================================}
function ZellerNum ( DT : DateTime ) : byte ;
var
century : word ;
begin
if DT.Month > 2
then DT.Month := DT.Month - 2
else
begin
DT.Month := DT.Month + 10 ;
DT.Year := DT.Year - 1
end ;
century := DT.Year div 100 ;
DT.Year := DT.Year mod 100 ;
ZellerNum := ( DT.Day - 1 +
( ( 13 * DT.Month - 1 ) div 5 )
+ ( 5 * DT.Year div 4 ) +
century div 4 - 2 * century + 1 ) mod 7 ;
end ;
{===================================================================
Return DayOfWeek from Julian Date
===================================================================}
function ZellerJulian ( R : real ) : byte ;
var
DT : DateTime ;
begin
FromJulian ( R , DT ) ;
ZellerJulian := ZellerNum ( DT ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
TIME
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
VALID
===================================================================}
function IsTimeValid ( DT : DateTime ) : boolean ;
begin
IsTimeValid := ( DT.Hour < 24 ) and
( DT.Min < 60 ) and
( DT.Sec < 60 ) ;
end ;
{===================================================================
FORCE - set to system time if not valid.
===================================================================}
procedure TimeForceValid ( VAR DT : DateTime ) ;
var
SysDateTime : DateTime ;
begin
GetDateTime ( SysDateTime ) ;
if DT.Hour > 23 then
DT.Hour := SysDateTime.Hour ;
if DT.Min > 59 then
DT.Min := SysDateTime.Min ;
if DT.Sec > 59 then
DT.Sec := SysDateTime.Sec ;
end ;
{===================================================================
DT --> "11:43:01am" 12 (am/pm)
DT --> "23:43:01 " 24 hr (military) mode
Note - Always allow 10 chars (am, pm or two spaces).
===================================================================}
function TimeToStr ( DT : DateTime ; Mode24 : boolean ) : string ;
var
AmPm : string ;
begin
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
24 HOUR
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
if Mode24 then
begin
AmPm := #32#32 ;
TimeToStr := PadLeft ( NumToStr ( DT.Hour ) , '0' , 2 )
+ ':'
+ PadLeft ( NumToStr ( DT.Min ) , '0' , 2 )
+ ':'
+ PadLeft ( NumToStr ( DT.Sec ) , '0' , 2 )
+ AmPm ;
EXIT ;
end ;
{- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
12 HOUR
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
if DT.Hour > 12 then
begin
AmPm := 'pm' ;
dec ( DT.Hour , 12 ) ;
end
else
begin
AmPm := 'am' ;
if DT.Hour = 0 then
DT.Hour := 12 ;
end ;
TimeToStr := PadLeft ( NumToStr ( DT.Hour ) , #32 , 2 )
+ ':'
+ PadLeft ( NumToStr ( DT.Min ) , '0' , 2 )
+ ':'
+ PadLeft ( NumToStr ( DT.Sec ) , '0' , 2 )
+ AmPm ;
end ;
{===================================================================
"10:43:01" --> DT
===================================================================}
procedure StrToTime ( S : string ; VAR DT : DateTime ) ;
begin
S := Replace ( S , ':' , #32 ) ;
DT.Hour := StrToWord ( pluck ( S , 1 ) ) ;
DT.Min := StrToWord ( pluck ( S , 2 ) ) ;
DT.Sec := StrToWord ( pluck ( S , 3 ) ) ;
end ;
{===================================================================
FROM
===================================================================}
procedure FromTotalSeconds ( Seconds : longint ; VAR DT : DateTime ) ;
begin
DT.Day := Seconds div 86400 ;
Seconds := Seconds mod 86400 ;
DT.Hour := Seconds div 3600 ;
Seconds := Seconds mod 3600 ;
DT.Min := Seconds div 60 ;
Seconds := Seconds MOD 60 ;
DT.Sec := Seconds ;
end ;
{===================================================================
TO
===================================================================}
function ToTotalSeconds ( DT : DateTime ) : longint ;
begin
ToTotalSeconds := LONGINT ( DT.Hour ) * 3600
+ DT.Min * 60
+ DT.Sec ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
DURATION
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
dd:hh:mm:ss --> "0 days, 0 hrs, 0 min, 0 sec"
===================================================================}
function DurationToStr ( DT : DateTime ) : string ;
begin
if DT.Day > 0 then
DurationToStr := NumToStr ( DT.Day )
+ ' days, '
+ TimeToStr ( DT , TRUE )
else
DurationToStr := TimeToStr ( DT , TRUE ) ;
end ;
{===================================================================
SECONDS - absolute
===================================================================}
function SecondsBetween ( DT1 , DT2 : DateTime ) : longint ;
begin
if CompareTime ( DT1 , DT2 ) = -1 then
SecondsBetween := ToTotalSeconds ( DT1 ) - ToTotalSeconds ( DT2 )
else
SecondsBetween := ToTotalSeconds ( DT2 ) - ToTotalSeconds ( DT1 ) ;
end ;
{===================================================================
DateTime1 , DateTime2 ==> ddddd:hh:mm:ss
DURATION - days, hours, minutes, seconds (no year or month)
===================================================================}
procedure GetDuration ( DT1 , DT2 : DateTime ; VAR Result : DateTime ) ;
var
TimeDiff : longint ;
DayDiff : longint ;
Midnight : DateTime ;
Zero : DateTime ;
begin
FillChar ( Result , SizeOf ( DateTime ) , #0 ) ;
FillChar ( Midnight , SizeOf ( DateTime ) , #0 ) ;
FillChar ( Zero , SizeOf ( DateTime ) , #0 ) ;
Midnight.Hour := 24 ;
case CompareDate ( DT1 , DT2 ) of
0 : TimeDiff := SecondsBetween ( DT1 , DT2 ) ;
-1 : TimeDiff := SecondsBetween ( DT2 , Midnight )
+ SecondsBetween ( Zero , DT1 ) ;
1 : TimeDiff := SecondsBetween ( DT1 , Midnight )
+ SecondsBetween ( Zero , DT2 ) ;
end ;
DayDiff := DaysBetween ( DT1 , DT2 ) - 1 ;
FromTotalSeconds ( TimeDiff , Result ) ;
if DayDiff > 0 then
inc ( Result.Day , DayDiff ) ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
FILE
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
SET
===================================================================}
function SetFileDateTime ( S : PathStr ; VAR DT : DateTime ) : boolean ;
var
Time : longint ;
F : file ;
OK : boolean ;
begin
SetFileDateTime := FALSE ;
DosError := 0 ;
OK := TRUE ;
PackTime ( DT , Time ) ;
{$I-}
Assign ( F , S ) ;
Reset ( F ) ;
if IOResult <> 0 then OK := FALSE ;
SetFTime ( F , Time ) ;
if IOResult <> 0 then OK := FALSE ;
Close ( F ) ;
{$I-}
if IOResult <> 0 then OK := FALSE ;
if DosError <> 0 then OK := FALSE ;
if not OK then EXIT ;
SetFileDateTime := TRUE ;
end ;
{===================================================================
GET
===================================================================}
function GetFileDateTime ( S : PathStr ; VAR DT : DateTime ) : boolean ;
var
Time : longint ;
F : file ;
OK : boolean ;
begin
GetFileDateTime := FALSE ;
DosError := 0 ;
OK := TRUE ;
FillChar ( DT , SizeOf ( DT ) , #0 ) ;
{$I-}
Assign ( F , S ) ;
Reset ( F ) ;
if IOResult <> 0 then OK := FALSE ;
GetFTime ( F , Time ) ;
if IOResult <> 0 then OK := FALSE ;
Close ( F ) ;
{$I-}
if IOResult <> 0 then OK := FALSE ;
if DosError <> 0 then OK := FALSE ;
if not OK then EXIT ;
UnpackTime ( Time , DT ) ;
GetFileDateTime := TRUE ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
REPORT - Preset for easy formatting
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
TIME --> '23:00'
===================================================================}
function Now : string ;
var
DT : DateTime ;
begin
GetDateTime ( DT ) ;
Now := TimeToStr ( DT , FALSE ) ;
end ;
{===================================================================
Date --> '1-Jan-89'
===================================================================}
function Today : string ;
var
DT : DateTime ;
begin
GetDateTime ( DT ) ;
Today := DateToStr ( DT , DateType ) ;
end ;
{===================================================================
Date & Time --> "1/1/1 0:0"
===================================================================}
function DateAndTimeToStr ( DT : DateTime ; WhichDateType : word ; Mode24 : boolean ) : string ;
begin
DateAndTimeToStr := DateToStr ( DT , WhichDateType )
+ #32
+ TimeToStr ( DT , Mode24 ) ;
end ;
{===================================================================
FILE - return formatted date string
===================================================================}
function FileDateStr ( S : PathStr ; WhichDateType : word ) : string ;
var
DT : DateTime ;
begin
if not GetFileDateTime ( S , DT ) then
DateForceValid ( DT ) ;
FileDateStr := DateToStr ( DT , WhichDateType ) ;
end ;
{===================================================================
FILE - return formatted time string
===================================================================}
function FileTimeStr ( S : PathStr ; Mode24 : boolean ) : string ;
var
DT : DateTime ;
begin
if not GetFileDateTime ( S , DT ) then
TimeForceValid ( DT ) ;
FileTimeStr := TimeToStr ( DT , Mode24 ) ;
end ;
{===================================================================
FILE - return formatted date/time string
===================================================================}
function FileDateTimeStr ( S : PathStr ; WhichDateType : word ; Mode24 : boolean ) : string ;
var
DT : DateTime ;
TempDateType : word ;
begin
TempDateType := DateType ;
if not GetFileDateTime ( S , DT ) then
begin
DateForceValid ( DT ) ;
TimeForceValid ( DT ) ;
end ;
FileDateTimeStr := DateAndTimeToStr ( DT ,
WhichDateType ,
Mode24 ) ;
DateType := TempDateType ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
COMPARE
-------
-1 First is later/newer
0 Equal
1 Second is later/newer
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
TIME
===================================================================}
function CompareTime ( DT1 , DT2 : DateTime ) : shortint ;
begin
if ToTotalSeconds ( DT1 ) = ToTotalSeconds ( DT2 ) then
CompareTime := 0
else
if ToTotalSeconds ( DT1 ) > ToTotalSeconds ( DT2 ) then
CompareTime := -1
else
CompareTime := 1 ;
end ;
{===================================================================
DATE
===================================================================}
function CompareDate ( DT1 , DT2 : DateTime ) : shortint ;
begin
if ToJulian ( DT1 ) = ToJulian ( DT2 ) then
begin
CompareDate := 0 ;
end
else
if ToJulian ( DT1 ) > ToJulian ( DT2 ) then
CompareDate := -1
else
CompareDate := 1 ;
end ;
{===================================================================
COMPARE
===================================================================}
function CompareDateTime ( DT1 , DT2 : DateTime ) : shortint ;
begin
if ToJulian ( DT1 ) = ToJulian ( DT2 ) then
CompareDateTime := CompareTime ( DT1 , DT2 )
else
if ToJulian ( DT1 ) > ToJulian ( DT2 ) then
CompareDateTime := -1
else
CompareDateTime := 1 ;
end ;
{===================================================================
FILE
===================================================================}
function CompareFileDateTime ( S1 , S2 : PathStr ) : shortint ;
var
dt1 : DateTime ;
dt2 : DateTime ;
begin
GetFileDateTime ( S1 , dt1 ) ;
GetFileDateTime ( S2 , dt2 ) ;
CompareFileDateTime := CompareDateTime ( dt1 , dt2 ) ;
end ;
{===================================================================
MAX
===================================================================}
function CompareMax ( x , y : real ) : shortint ;
begin
if x > y then CompareMax := -1 else
if x < y then CompareMax := 1 else
CompareMax := 0 ;
end ;
{===================================================================
MIN
===================================================================}
function CompareMin ( x , y : real ) : shortint ;
begin
if x < y then CompareMin := -1 else
if x > y then CompareMin := 1 else
CompareMin := 0 ;
end ;
{|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
MAX & MIN
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
{===================================================================
REAL
===================================================================}
function MaxMinReal ( x , y : real ; Max : boolean ) : real ;
begin
MaxMinReal := y ;
if Max then
begin
if CompareMax ( x , y ) = -1 then
MaxMinReal := x ;
EXIT ;
end ;
if CompareMin ( x , y ) = -1 then
MaxMinReal := x ;
end ;
{===================================================================
LONGINT
===================================================================}
function MaxMinLongint ( x , y : longint ; Max : boolean ) : longint ;
begin
MaxMinLongint := y ;
if Max then
begin
if CompareMax ( x , y ) = -1 then
MaxMinLongint := x ;
EXIT ;
end ;
if CompareMin ( x , y ) = -1 then
MaxMinLongint := x ;
end ;
{===================================================================
INTEGER
===================================================================}
function MaxMinInteger ( x , y : integer ; Max : boolean ) : integer ;
begin
MaxMinInteger := y ;
if Max then
begin
if CompareMax ( x , y ) = -1 then
MaxMinInteger := x ;
EXIT ;
end ;
if CompareMin ( x , y ) = -1 then
MaxMinInteger := x ;
end ;
{===================================================================
WORD
===================================================================}
function MaxMinWord ( x , y : word ; Max : boolean ) : word ;
begin
MaxMinWord := y ;
if Max then
begin
if CompareMax ( x , y ) = -1 then
MaxMinWord := x ;
EXIT ;
end ;
if CompareMin ( x , y ) = -1 then
MaxMinWord := x ;
end ;
{===================================================================
BYTE
===================================================================}
function MaxMinByte ( x , y : byte ; Max : boolean ) : byte ;
begin
MaxMinByte := y ;
if Max then
begin
if CompareMax ( x , y ) = -1 then
MaxMinByte := x ;
EXIT ;
end ;
if CompareMin ( x , y ) = -1 then
MaxMinByte := x ;
end ;
